home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #15 / Monster Media Number 15 (Monster Media)(July 1996).ISO / prog_d / heaptrac.zip / HEAPTRAC.EXE / HEAPTRAC.INT < prev    next >
Text File  |  1996-04-10  |  7KB  |  209 lines
  1. {
  2. // HeapTrace
  3. //   Dynamic memory debugging for Borland Delphi.
  4. //
  5. // ⌐ 1996, Modelistica, Caracas. All rights reserved
  6. //   73000.1064@compuserve.com
  7. }
  8. unit HeapTrac;
  9. { Tracing module }
  10. interface
  11. uses
  12.   SysUtils;
  13.  
  14. {$i HTCRight.pas }
  15.  
  16. type
  17.   TMemSize  = Longint;
  18.   PMemSize  = ^TMemSize;
  19.   TMemTime  = Longint;    { miliseconds }
  20.  
  21. type
  22.   { tracing options }
  23.   THeapTraceOption = (
  24.       htoLogAlloc,           { log allocations     }
  25.       htoLogFree,            { log deallocations   }
  26.       htoLogResize,          { log resizes         }
  27.       htoLogErrors,          { log errors          }
  28.       htoRaiseOnErrors,      { generate exceptions }
  29.       htoIgnoreZeroNil,      { ignored GetMem(p, 0) and FreeMem(nil, N) errors }
  30.       htoProfiling,          { create an in memory log }
  31.       htoCheckForLeaks,    { check for unfreed blocks at shutdown  }
  32.       htoConfigDialog,       { launch configuration dialog at startup }
  33.       htoProfileDialog,      { launch memory profile dialog at shutdown }
  34.       htoEraseOldLog
  35.     );
  36.   THeapTraceOptions = set of THeapTraceOption;
  37.  
  38. const
  39.   htoFullTrace = [htoLogAlloc..htoLogErrors];
  40.  
  41. { these are the events that HeapTrace watches }
  42. type
  43.   THeapTraceEvent = (
  44.       hteInternalError,
  45.       hteAllocated,
  46.       hteFreed,
  47.       hteResized,
  48.       hteFreeInvalid,
  49.       hteOverrun,
  50.       hteInvalid,
  51.       hteNotFreed,
  52.       hteFreeNil,
  53.       hteInvalidSize,
  54.       hteSizeIsZero,
  55.       hteOutOfMemory,
  56.       hteFakeOutOfMemory
  57.   );
  58.   THeapTraceRaisableEvent = hteFreeInvalid..hteInvalidSize;
  59.  
  60. const
  61.   HeapTraceRaisableEvents = [Low(THeapTraceRaisableEvent)..High(THeapTraceRaisableEvent)];
  62.  
  63. const
  64.   HTEventText : array[THeapTraceEvent] of PChar = (
  65.       {hteInternalError}   'Errror        !!',
  66.       {hteAllocated}       'Allocated       ',
  67.       {hteFreed}           'Freed           ',
  68.       {hteResized}         'Resized         ',
  69.       {hteFreeInvalid}     'Free Invalid  !!',
  70.       {hteOverrun}         'Overrun       !!',
  71.       {hteInvalid}         'Invalid       !!',
  72.       {hteNotFreed}        'Not Freed     !!',
  73.       {hteFreeNil}         'Free Nil      !!',
  74.       {hteInvalidSize}     'Invalid Size  !!',
  75.       {hteSizeIsZero}      'Size is Zero  !!',
  76.       {hteOutOfMemory}     'Out of Memory !!',
  77.       {hteFakeOutOfMemory} 'Fake No Memory!!'
  78.   );
  79.  
  80. type
  81.   TAllocation = class
  82.   public
  83.      function  MemPtr       :Pointer;           virtual; export;
  84.      function  MemSize      :TMemSize;          virtual; export;
  85.      function  WhereCreated :Pointer;           virtual; export;
  86.      function  WhenCreated  :TMemTime;         virtual; export;
  87.      function  WhereFreed   :Pointer;           virtual; export;
  88.      function  WhenFreed    :TMemTime;         virtual; export;
  89.      function  LifeTime     :TMemTime;         virtual; export;
  90.      function  Valid        :Boolean;           virtual; export;
  91.      function  ObjectClass  :TClass;            virtual; export;
  92.      function  Options      :THeapTraceOptions; virtual; export;
  93.      function  Freed        :Boolean;           virtual; export;
  94.  
  95.      function  Next         :TAllocation;       virtual; export;
  96.   end;
  97.  
  98. function HeapTraceIniFileName :string;
  99.  
  100. type
  101.   { exceptions raised by this HeapTrace are never freed }
  102.   EHeapTrace            = class(Exception)
  103.     constructor Create;
  104.     destructor Destroy;      override; { do nothing }
  105.     destructor Kill;                   { real destructor }
  106.     procedure FreeInstance;  override;
  107.   end;
  108.  
  109.   { these are exceptions raised by HeapTrace }
  110.   EHeapTraceInvalid        = class(EHeapTrace);
  111.   EHeapTraceNil            = class(EHeapTrace);
  112.   EHeapTraceInvalidSize    = class(EHeapTrace);
  113.   EHeapTraceFreeInvalid    = class(EHeapTrace);
  114.   EHeapTraceNotFreed       = class(EHeapTrace);
  115.   EHeapTraceOverrun        = class(EHeapTrace);
  116.   EHeapTraceSizeIsZero     = class(EHeapTrace);
  117.   EHeapTraceTooLarge       = class(EHeapTrace);
  118.   EHeapTraceInternalError  = class(EHeapTrace);
  119.   EHeapTraceInvalidLogProc = class(EHeapTrace);
  120.   EHTAllocationChainTooLong= class(EHeapTrace); 
  121.  
  122.   { raised when HeapTrace simulates an Out of Memory condition }
  123.   EHTSimulatedOutOfMemory = class(EOutOfMemory);
  124.  
  125. { setting/getting options }
  126. function  HeapTraceOptions :THeapTraceOptions;
  127. procedure SetHeapTraceOptions(Value :THeapTraceOptions);
  128. procedure ChangeHeapTraceOptions(Value :THeapTraceOptions; Enable :Boolean);
  129.  
  130. { logging }
  131. function  HeapTraceDefaultLogFileName :string;
  132. procedure HTDefaultLog(const Msg :string);
  133. procedure HTDefaultLogMem(Mem :Pointer; Size :TMemSize; C :TClass; Addr :Pointer; Event :THeapTraceEvent);
  134. procedure HTDefaultLogAlloc(a :TAllocation; Addr :Pointer; Event :THeapTraceEvent);
  135.  
  136. const
  137.    { Log is used by LogMem for final output }
  138.    Log      :procedure(const Msg :string)
  139.              = HTDefaultLog;
  140.    LogMem   :procedure(Mem :Pointer; Size :TMemSize; C :TClass; Addr :Pointer; Event :THeapTraceEvent)
  141.              = HTDefaultLogMem;
  142.    { by default, LogAlloc directs it's output to LogMem }
  143.    LogAlloc :procedure(a :TAllocation; Addr :Pointer; Event :THeapTraceEvent)
  144.              = HTDefaultLogAlloc;
  145.  
  146. { traced-heap information routines }
  147. function  TracedMemSize(Mem :Pointer):TMemSize;
  148. function  TracedMemoryValid(Mem :Pointer; Size :TMemSize):Boolean;
  149.  
  150. { simluating out of memory conditions }
  151. function  HeapTraceAvailableMemory :TMemSize;
  152. procedure SetHeapTraceAvailableMemory(NewSize :TMemSize);
  153. function  HeapTraceAllocatedMemory    :TMemSize;
  154. function  HeapTraceMaxAllocatedMemory :TMemSize;                                     
  155.  
  156. { the garbage character is used to erase unused memory }
  157. function  HeapTraceGarbageChar :Char;
  158. procedure SetHeapTraceGarbageChar(Value :Char);
  159.  
  160. { hook to perform actions after HeapTrace has shut down }
  161. type
  162.   THTShutDownProc = procedure;
  163.  
  164.   procedure HeapTraceOnShutdownDo(Proc: THTShutDownProc);
  165.  
  166. { check the heap for blocks that were not freed }
  167.   function  HeapTraceAllocationChain :TAllocation;
  168.   procedure HeapTraceCheckForMemoryLeaks;
  169.   procedure HeapTraceClearAllocationChain;
  170.  
  171. { The declarations here on should not be of interest to
  172.   most users.  They are low level stuff useful only to
  173.   developers building enhancements to HeapTrace }
  174.  
  175. function HeapTraceActive :Boolean;
  176.  
  177. { a safe way to test for an object's type }
  178. function SafeIsOper(P :Pointer; C : TClass) : Boolean;
  179. function SafeCast(P : Pointer; C : TClass) : Pointer;
  180.  
  181. function SafeClassType(P :Pointer)   :TClass;
  182. function SafeClassParent(C :TClass)  :TClass;
  183. function SafeInstanceSize(P :Pointer):TMemSize;
  184.  
  185. function SafeConvertAddr(Address: Pointer): Pointer;
  186. function ConvertExceutableAddr(Addr :Pointer):Pointer;
  187.  
  188. function CallerAddr        :Pointer;
  189. function CallersCallerAddr :Pointer;
  190. function AddressAtIPOffset(Offset :Integer):Pointer;
  191.  
  192. function MemSizeToStr(Size :Double):string;
  193. function StrToMemSize(s:string):TMemSize;
  194.  
  195. type
  196.   PtrToLong = Longint;
  197.   LongToPtr = Pointer;
  198.   PPointer = ^Pointer;
  199.  
  200.   TMemEvent   = procedure (Mem :Pointer; Size :TMemSize; C :TClass; Addr :Pointer; Event :THeapTraceEvent);
  201.   TAllocEvent = procedure (a :TAllocation; Addr :Pointer; Event :THeapTraceEvent);
  202.  
  203.   function VerMinor :Integer;
  204.   function VerMajor :Integer;
  205.   function VerDot   :Integer;
  206.   function VerName  :PChar;
  207.  
  208. implementation
  209. end.